home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pnl004.zip / PROFILE.PAS < prev    next >
Pascal/Delphi Source File  |  1990-02-15  |  5KB  |  177 lines
  1. unit profile;
  2. (* (c) Jan-Erik Rosinowski 1989, 1990 *)
  3.  
  4. interface
  5.  
  6. procedure pbegin(nr:word);
  7. procedure pend;
  8. procedure specfile(name:string; ext:string);
  9.  
  10. implementation
  11.  
  12. uses
  13.   crt;
  14.  
  15. const
  16.   stacksize        = 5000;             (* no. of stack-components *)
  17.   maxprocedures    = 300;              (* max. no. of procedures *)
  18.   fracs            = 2;                (* no of frac digits *)
  19.   base             = 1000;             (* use ms as orientation-base *)
  20.   clockrate        = 1193181.6667;     (* ticks per second *)
  21.   maxcardinal      = 4294967296.0;     (* 2^32 *)
  22.   adjustruns       = 1000;             (* runs to determine rel. zero *)
  23.   safetyfactor     = 0.8;              (* correction of adjusttimer to prevent underflow *)
  24.  
  25. type
  26.   stacktype        = array[0..stacksize] of word;
  27.  
  28.   procstoretype    = array[0..maxprocedures] of record
  29.                                                   calls  : longint;
  30.                                                   time   : longint;
  31.                                                 end;
  32.  
  33. var
  34.   nameoftempfile   : string[64];
  35.   profileextension : string[4];
  36.   stack            : stacktype;
  37.   stackptr         : word;
  38.   procstore        : procstoretype;
  39.   savedexitproc    : pointer;
  40.   adjusttimer      : longint;
  41.   procstart        : longint;
  42.   min              : longint;
  43.   q                : word;
  44.  
  45. procedure specfile;
  46. begin
  47.   nameoftempfile:=name;
  48.   profileextension:=ext;
  49. end;
  50.  
  51. procedure inittimer; external;
  52. procedure restoretimer; external;
  53. function readtimer:longint; external;
  54. (*$L protimer *)
  55.  
  56. function long2real(l:longint):real;
  57. begin
  58.   if l<0 then long2real:=maxcardinal+l
  59.   else long2real:=l;
  60. end;
  61.  
  62. (*$F+*)
  63. procedure writeprofile;
  64.  
  65. var
  66.   tempfile         : text;
  67.   profile          : text;
  68.   profilename      : string;
  69.   path             : string;
  70.   iores            : word;
  71.   procnr           : word;
  72.   line             : string;
  73.   error            : boolean;
  74.  
  75. function nicetime(t:longint):string;
  76. var
  77.   nice             : string[20];
  78. begin
  79.   str(long2real(t)*base/clockrate:17:fracs,nice);
  80.   nicetime:=nice;
  81. end;
  82.  
  83. begin
  84.   if stackptr<>stacksize then
  85.     begin
  86.       error:=stackptr<>0;
  87.       while stackptr<>0 do pend;
  88.       if nameoftempfile='' then
  89.         begin
  90.           clrscr;
  91.           writeln('** Internal Error occured in PROFILE-Unit **',#7);
  92.           write('Please specify profile''s name :');
  93.           readln(nameoftempfile);
  94.         end;
  95.       profilename:=copy(nameoftempfile,1,
  96.                      length(nameoftempfile)-4)+profileextension;
  97.       path:='';
  98.       repeat
  99.         assign(tempfile,path+nameoftempfile);
  100.         (*$i-*)
  101.         reset(tempfile);
  102.         (*$i+*)
  103.         iores:=ioresult;
  104.         if iores<>0 then
  105.           begin
  106.             clrscr;
  107.             write('Cannot find profile², please enter path :');
  108.             readln(path);
  109.           end;
  110.       until iores=0;
  111.       assign(profile,path+profilename);
  112.       rewrite(profile);
  113.       while not eof(tempfile) do
  114.         begin
  115.           read(tempfile,procnr); readln(tempfile,line);
  116.           with procstore[procnr] do
  117.             writeln(profile,copy(line,2,pred(length(line))),calls:6,
  118.               nicetime(time));
  119.         end;
  120.       if error then
  121.         writeln(profile,#13#10'!! Program terminated due to Halt or Error !!');
  122.       close(tempfile);
  123.       close(profile);
  124.     end;
  125.   restoretimer;
  126.   exitproc:=savedexitproc;
  127. end;
  128. (*$F-*)
  129.  
  130. procedure pbegin;
  131. begin
  132.   if stackptr>0 then
  133.     with procstore[stack[stackptr]] do
  134.       inc(time,readtimer-procstart-adjusttimer);
  135.   if stackptr=stacksize then
  136.     begin
  137.       clrscr;
  138.       writeln('** Stack Overflow in PROFILE-Unit. **'#7);
  139.       halt(1);
  140.     end;
  141.   inc(stackptr);
  142.   inc(procstore[nr].calls);
  143.   stack[stackptr]:=nr;
  144.   procstart:=readtimer;
  145. end;
  146.  
  147. procedure pend;
  148. begin
  149.   with procstore[stack[stackptr]] do
  150.     inc(time,readtimer-procstart-adjusttimer);
  151.   dec(stackptr);
  152.   procstart:=readtimer;
  153. end;
  154.  
  155. begin
  156.   savedexitproc:=exitproc;
  157.   exitproc:=@writeprofile;
  158.   nameoftempfile:='';
  159.   inittimer;
  160.   stackptr:=0;
  161.   fillchar(procstore,sizeof(procstore),0);
  162.   adjusttimer:=0;
  163.   pbegin(0);
  164.   min:=maxlongint;
  165.   for q:=1 to adjustruns do
  166.     begin
  167.       pbegin(1); pend;
  168.       with procstore[1] do
  169.         begin
  170.           if time<min then min:=time;
  171.           time:=0;
  172.         end;
  173.     end;
  174.   pend;
  175.   adjusttimer:=trunc(min*safetyfactor);
  176.   fillchar(procstore,sizeof(procstore),0);
  177. end.